(setf *print-circle* T)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PPRINT STATE - Blocks World
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setf pprint-state* t)

;;; Sample Target printouts:
;; NEW FORMAT:

;; STATE:
;;  Holding: NIL
;;
;;     +--+
;;     |C1|
;;     +--+  
;;     |B0|
;;     +--+  +--+
;;     |A2|  |D1|
;;  +--+--+--+--+--+--+
;;  |T0 T0 T0 T0 T0 T0|
;;  +--+--+--+--+--+--+

;; STATE:
;;  Holding: C1 (2x2)
;;
;;     +--+     +--+
;;     |B0|     |E2|
;;     +--+  +--+  +
;;     |A2|  |D1|E2|
;;  +--+--+--+--+--+--+
;;  |T0 T0 T0 T0 T0 T0|
;;  +--+--+--+--+--+--+


(defun pprint-state (&optional (state state*))
  (terpri)
  ;(princ "STATE:")
  (terpri)
  (princ (hand-string state))
  (let* ((block-triples (get-block-triples (get-raw-block-triples state)))
	 ;; block-array holds only cells with block-names
	 (block-array (make-block-array block-triples))
	 (state-array (make-state-array block-array state)))
    (pprint-2d-array state-array)))

(defun hand-string (state)
  (let ((hand-status (get-hand-status state)))
    (case hand-status 
      ((empty nil) (format nil "Holding: NIL"))
      (t (format nil "Holding: ~a" 
		 ;(block-name-with-dims hand-status state)
		 (block-name-string hand-status state)
		 )))))

(defun get-hand-status (state)
  (second (member 'status (assoc 'hand state))))

(defun form-from-name (name state)
  (first (member name state :key #'second)))
  
(defun block-name-with-dims (block-name state)
  (let* ((block-form (form-from-name block-name state))
	 (block-width (second (member 'width block-form)))
	 (block-height (second (member 'height block-form)))
	 (block-shade (second (member 'shade block-form)))
	 (block-name-with-shade (block-name-string block-name state)))
    ;; example " B2  (width:3, height:1) "
    (format nil " ~a (width:~a, height:~a) "
	    block-name-with-shade block-width block-height)))


;; Need to omit block if being held by hand
;; raw block triples of form: (blockname x y)
;; Note: Table is treated as another block
;; A separate triple is created for each cell occupied by a block or the table
(defun get-raw-block-triples (state)
  (loop with hand-status = (get-hand-status state)
     for form in state
     for object-name = (second form)
     when (and (member (first form) '(block table))  ;; include table and blocks
	       (not (eql object-name hand-status)))
     append
       (all-triples-for-block-form form)))

;; this expands a single block triple into a list of triples,
;;     one triple for each cell covered by the block
(defun all-triples-for-block-form (blockform)
  (let ((block-name (second blockform))
	(block-x (second (member 'xpos blockform)))
	(block-y (second (member 'ypos blockform)))
	(block-width (second (member 'width blockform)))
	(block-height (second (member 'height blockform))))
    (loop for dx from 0 below block-width
	 append
	 (loop for dy from 0 below block-height
	      collect
	      (list block-name (+ block-x dx) (+ block-y dy))))))


;; convert coordinates to row col for array
;;    block-y determines row
;;    block-x determines col
;;  No longer assumes coords are even
;;  returns triples in form: (block-name row col)
(defun get-block-triples (raw-block-triples)
  (let ((max-y (loop for triple in raw-block-triples
		  maximize (third triple))))
    (loop for (name x y) in raw-block-triples
	 collect
	 (list name
	       (- max-y y)       ; row
	       x))))     	 ; col

;; triple format is now: (name row col)
(defun make-block-array (block-triples)
  (let* ((max-row (loop for triple in block-triples
		     maximize (second triple)))
	 (max-col (loop for triple in block-triples
		     maximize (third triple)))
	 (block-array (make-array (list (1+ max-row) ; 0 to max-row plus line for table
					(1+ max-col)) ; 0 to max-col
				  :initial-element nil)))
    (loop for (name row col) in block-triples
       do
       (setf (aref block-array row col)
	     name))
    block-array))

(defun make-state-array (block-array state)
  ;; NOTE: arg is NOW: block-array, BEFORE WAS: block-triples
  (let* ((block-rows (array-dimension block-array 0))
	 (block-cols (array-dimension block-array 1))
	 (state-array (make-array (list (1+ (* 2 block-rows))
					(1+ (* 2 block-cols)))
				  :initial-element " ")))
    (loop for row from 0 below block-rows
	 do
	 (loop for col from 0 below block-cols
	      do
	      (process-cell row col block-array state-array state)))
    state-array))

(defun process-cell (row col block-array state-array state)
  (let* ((cell-contents (cell-contents row col block-array))
	 (up-border? (not (eql cell-contents (cell-contents (1- row) col block-array))))
	 (down-border? (not (eql cell-contents (cell-contents (1+ row) col block-array))))
	 (left-border? (not (eql cell-contents (cell-contents row (1- col) block-array))))
	 (right-border? (not (eql cell-contents (cell-contents row (1+ col) block-array))))
	 (state-row (1+ (* 2 row)))
	 (state-col (1+ (* 2 col))))
    (set-cell-name cell-contents state-row state-col state-array state)
    (set-hor-border up-border? (1- state-row) state-col state-array)
    (set-hor-border down-border? (1+ state-row) state-col state-array)
    (set-ver-border left-border? state-row (1- state-col) state-array)
    (set-ver-border right-border? state-row (1+ state-col) state-array)))

;; this safely returns NIL if row col are out of bounds
(defun cell-contents (row col array)
  (when (array-in-bounds-p array row col)
    (aref array row col)))

(defun set-cell-name (cell-contents state-row state-col state-array state)
  (setf (aref state-array state-row state-col)
	(if cell-contents
	    (block-name-string cell-contents state)
	    "  ")))

(defun block-name-string (block state)
  (let* ((block-form (form-from-name block state))
	 (block-shade (second (member 'shade block-form))))
  (format nil "~a~a" 
	  (first-letter-string block)
	  (if block-shade
	      block-shade
	      " "))))

(defun first-letter-string (block-name)
  (subseq (format nil "~a" block-name) 0 1))

(defparameter pprint-plus-signs? t)

;; also set the corners to "+" if desired??
(defun set-hor-border (border? state-row state-col state-array)
  (setf (aref state-array state-row state-col)
	(if border? "--" "  "))
  (when (and border? pprint-plus-signs?)
    (setf (aref state-array state-row (1- state-col))
	  "+")
    (setf (aref state-array state-row (1+ state-col))
	  "+")))

(defun set-ver-border (border? state-row state-col state-array)
  (setf (aref state-array state-row state-col)
	(if border? "|" " "))
  (when (and border? pprint-plus-signs?)
    (setf (aref state-array (1- state-row) state-col)
	  "+")
    (setf (aref state-array (1+ state-row) state-col)
	  "+")))

(defun pprint-2d-array (2d-array)
  (loop for row from 0 below (array-dimension 2d-array 0)
       do
       (terpri)
       (loop for col from 0 below (array-dimension 2d-array 1)
	    do
	    (format t "~a" (aref 2d-array row col)))))
